home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istvw / ISTVW.MAC.f
Encoding:
Text File  |  1989-03-04  |  13.2 KB  |  433 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.5
  3. C---------------------------------------------------------
  4. C *****************************
  5. C *  Note:  The following macro definition should be set to the
  6. C *         maximum number of symbols expected in any single
  7. C *         program-unit.  On a virtual-memory system, it can
  8. C *         be set to the maximum number of symbols possible,
  9. C *         i.e.    "define(max_pu_syms,max_symbols)"
  10. C *
  11. C *         For non-virtual systems, this may take up too much space,
  12. C *         so make it smaller, e.g.
  13. C *                 "define(max_pu_syms,500)"
  14. C *****************************
  15. C * The following setting is in use at NAG Central Office:
  16.         PROGRAM ISTVW
  17.  
  18.         COMMON/VSIO/IODSYM,IODLST
  19.         INTEGER IODSYM,IODLST
  20.  
  21.         COMMON/VSSYMI/SYMIDX,NSYMS
  22.         INTEGER SYMIDX(1000),NSYMS
  23.  
  24.         INTEGER HEADER(81),SYMPTH(81),LSTPTH(81),I,
  25.      +          YY,MMM,DD,HH,MM,SS,MILLI
  26.  
  27.         INTEGER GETARG,OPEN,CREATE
  28.         EXTERNAL GETARG,OPEN,CREATE,ZYINSY,ZINIT,ZQUIT,ZMESS,PUTLIN,
  29.      +           PUTCH,ZTIME,ZTIMST,ZCHOUT
  30.  
  31.         CALL ZINIT
  32.  
  33.         IF (GETARG(1,SYMPTH,81).EQ.-100) CALL NAMES(1,SYMPTH)
  34.         IF (GETARG(2,LSTPTH,81).EQ.-100) CALL NAMES(2,LSTPTH)
  35.         IF (GETARG(3,HEADER,81).EQ.-100) CALL NAMES(3,HEADER)
  36.  
  37.         IODSYM=OPEN(SYMPTH,0)
  38.         IF (IODSYM.EQ.-1) CALL ERROR('Can''t open symbol path')
  39.         IODLST=CREATE(LSTPTH,1)
  40.         IF (IODLST.EQ.-1) CALL ERROR('Can''t create list path')
  41.  
  42.         CALL ZYINSY(IODSYM)
  43.  
  44.         CALL PUTLIN(HEADER,IODLST)
  45.         CALL ZCHOUT(': Simple Warnings Listing, ',IODLST)
  46.         CALL ZTIME(YY,MMM,DD,HH,MM,SS,MILLI)
  47.         CALL ZTIMST(YY,MMM,DD,HH,MM,SS,HEADER)
  48.         CALL PUTLIN(HEADER,IODLST)
  49.         CALL PUTCH(10,IODLST)
  50.         I=1
  51.  
  52.  100    CALL ZYGSSI(SYMIDX,NSYMS,I)
  53.         IF (NSYMS.EQ.0) THEN
  54.             CALL PUTCH(10,1)
  55.             CALL ZMESS('[ISTVW Normal Termination]',1)
  56.             CALL ZQUIT(-2)
  57.         END IF
  58.         CALL GETDAT
  59.         CALL SRTIDX
  60.         CALL PRINTS
  61.         I=I+1
  62.         GO TO 100
  63.  
  64.         END
  65. C ----------------------------------------------------------------------
  66. C
  67. C       N A M E S   -   Input names of files and so on
  68. C
  69.  
  70.         SUBROUTINE NAMES(NUMBER,STRING)
  71.         INTEGER NUMBER,STRING(81)
  72.  
  73.         INTEGER PROMPT(22,3),JUNK
  74.  
  75.         SAVE PROMPT
  76.  
  77.         INTEGER ZGTCMD
  78.         EXTERNAL ZPRMPT,ZGTCMD
  79.  
  80. C "Input symbol table: "
  81. C "Output listing file: "
  82. C "Header text: "
  83.  
  84.         DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,115,
  85.      +121,109,98,111,108,32,116,97,98,108,101,58,
  86.      +32,129/,
  87.      +       (PROMPT(I,2),I=1,22)/79,117,116,112,117,116,32,
  88.      +108,105,115,116,105,110,103,32,102,105,108,101,
  89.      +58,32,129/,
  90.      +       (PROMPT(I,3),I=1,14)/72,101,97,100,101,114,32,
  91.      +116,101,120,116,58,32,129/
  92.  
  93.         CALL ZPRMPT(PROMPT(1,NUMBER))
  94.         JUNK=ZGTCMD(STRING,0)
  95.  
  96.         END
  97. C ----------------------------------------------------------------------
  98. C
  99. C       G E T D A T   -   Get symbol data
  100. C
  101.  
  102.       SUBROUTINE GETDAT
  103.  
  104.       COMMON/VSSYMI/SYMIDX,NSYMS
  105.       INTEGER SYMIDX(1000),NSYMS
  106.  
  107.       COMMON/VSSYMD/SYMBOL
  108.       INTEGER SYMBOL(8,1000)
  109.  
  110.       INTEGER I
  111.  
  112.       DO 100 I=1,NSYMS
  113.         CALL ZYGTSY(SYMIDX(I),SYMBOL(1,I))
  114.   100 CONTINUE
  115.       END
  116. C ----------------------------------------------------------------------
  117. C
  118. C       S R T I D X   -   Sort symbol index
  119. C
  120. C       Sort key: Symbol type (then) Current position
  121. C                 (Current position is as sorted by name)
  122. C
  123.  
  124.         SUBROUTINE SRTIDX
  125.  
  126.         COMMON/VSSYMI/SYMIDX,NSYMS
  127.         INTEGER SYMIDX(1000),NSYMS
  128.  
  129.         COMMON/VSSYMD/SYMBOL
  130.         INTEGER SYMBOL(8,1000)
  131.  
  132.         INTEGER I,J,K,TMP(8),T
  133.  
  134. C We will use a form of straight insertion
  135.         DO 300 I=2,NSYMS
  136.             J=I-1
  137. C while J>1 and a(i).lt.a(j) do j=j-1
  138.  100        IF (SYMBOL(1,I) .LT. SYMBOL(1,J)) THEN
  139.                 J=J-1
  140.                 IF (J.GE.1) GOTO 100
  141.             END IF
  142.             J=J+1
  143.             DO 150 T=1,8
  144.  150            TMP(T)=SYMBOL(T,I)
  145.             DO 250 K=I,J+1,-1
  146.                 DO 200 T=1,8
  147.  200                SYMBOL(T,K)=SYMBOL(T,K-1)
  148.  250        CONTINUE
  149.             DO 275 T=1,8
  150.  275            SYMBOL(T,J)=TMP(T)
  151.  300    CONTINUE
  152.         END
  153. C ----------------------------------------------------------------------
  154. C
  155. C       P R I N T S   -   Print Symbols
  156. C
  157. C (a) decl_externl: The name appears in an EXTERNAL statement.
  158. C (b) decl_intrins: The name appears in an INTRINSIC statement.
  159. C (c) formal_param:   The  name  is  a  formal  parameter  (dummy
  160. C     argument) of the program unit.
  161. C (d) explicit_typ: The name appears in a type statement,  or  if
  162. C     it  is  a  function subprogram name, has the type specified
  163. C     in the FUNCTION statement.
  164. C (e) in_ASSIGN: The name appears in an ASSIGN statement.
  165. C (f) assigned_to: The name appears on the left-hand side  of  an
  166. C     assignment statement.
  167. C (g) in_READ_list:  The name appears in the input-list of a READ
  168. C     statement.
  169. C (h) in_DATA_stmt: The name appears in a DATA statement.
  170. C (i) stmt_fn_para:  The  name  is  a  formal  parameter   (dummy
  171. C     argument) of a statement function.
  172. C (j) in_EQUIV: The name appears in an EQUIVALENCE statement.
  173. C (k) in_COMMON: The name appears in a COMMON statement.
  174. C (l) used_as_arg:  The  name is used as the actual argument to a
  175. C     called function or subroutine.
  176. C (m) std_intrinsic: The name is that  of  a  standard  intrinsic
  177. C     function.
  178. C (n) fun_called: The name is called as a function.
  179. C (o) in_expr: The name appears in an expression.
  180. C (p) sub_called: The name is called as a subroutine.
  181. C (q) doloop_index:  The name is used as the controlling variable
  182. C     in a DO statement or implicit DO-loop.
  183. C (r) use_bits: This macro is actually the inclusive  or  of  the
  184. C     bits:  formal_param,  in_ASSIGN, assigned_to, in_READ_list,
  185. C     in_DATA_stmt,    stmt_fn_para,    in_EQUIV,    used_as_arg,
  186. C     fun_called, in_expr, sub_called and doloop_index.
  187. C
  188.         SUBROUTINE PRINTS
  189.  
  190.         COMMON/VSIO/IODSYM,IODLST
  191.         INTEGER IODSYM,IODLST
  192.  
  193.         COMMON/VSSYMI/SYMIDX,NSYMS
  194.         INTEGER SYMIDX(1000),NSYMS
  195.  
  196.         COMMON/VSSYMD/SYMBOL
  197.         INTEGER SYMBOL(8,1000)
  198.  
  199.         LOGICAL IMPLI
  200.         INTEGER I,COUNT,MASK,KEY(134),ZIAND
  201.  
  202.         EXTERNAL ZCHOUT,PUTCH,ZOBLNK,ZPTINT,ZIAND
  203.  
  204.         I=0
  205.  100    I=I+1
  206.         IF (SYMBOL(1,I).NE.4) GOTO 100
  207.  
  208.         CALL PUTCH(10,IODLST)
  209.         CALL ZCHOUT('Program Unit: ',IODLST)
  210.         CALL WRNAME(I)
  211.  
  212.         IMPLI = .TRUE.
  213.         MASK  = 16 + 32 + 64 + 128 +
  214.      +          65536 + 4 + 2048 + 1024 +
  215.      +          512
  216.  
  217.         COUNT = 0
  218.         DO 20 I = 1,NSYMS
  219.           CALL ZYGTST(SYMBOL(2,I),KEY)
  220. C
  221. C  CHECK LABELS
  222. C
  223.           IF(SYMBOL(1,I) .EQ. 1) THEN
  224.             IF(SYMBOL(5,I) + SYMBOL(6,I) +
  225.      +         SYMBOL(7,I) .EQ. 0) THEN
  226.               COUNT = COUNT + 1
  227.               CALL ZCHOUT('  Unused Label: ', IODLST)
  228.               CALL ZPTMES(KEY, IODLST)
  229.             ENDIF
  230. C
  231. C  CHECK UNUSED SIMPLE VARIABLES
  232. C
  233.           ELSE IF(SYMBOL(1,I) .EQ. 3) THEN
  234.               COUNT = COUNT + 1
  235.               IF(ZIAND(SYMBOL(6,I), 4) .NE. 0) THEN
  236.                 CALL ZCHOUT('  Unused dummy argument: ', IODLST)
  237.               ELSE
  238.                 CALL ZCHOUT('  Unused symbol: ', IODLST)
  239.               ENDIF
  240.               CALL ZPTMES(KEY, IODLST)
  241. C
  242. C  CHECK NAMES.....
  243. C
  244.           ELSE IF(SYMBOL(1,I) .EQ. 5) THEN
  245.             IF (ZIAND(SYMBOL(6,I),8).EQ.0 .AND.
  246.      +          IMPLI) THEN
  247.                 CALL ZCHOUT('  Implicitly typed variable: ', IODLST)
  248.                 COUNT = COUNT + 1
  249.                 CALL WRNAME(I)
  250.             END IF
  251.             IF((ZIAND(SYMBOL(6,I), 125936) .EQ. 0) .AND.
  252.      +         (ZIAND(SYMBOL(6,I), 1024) .EQ. 0)) THEN
  253.               COUNT = COUNT + 1
  254.               IF(ZIAND(SYMBOL(6,I), 4) .NE. 0) THEN
  255.                 CALL ZCHOUT('  Unused dummy argument: ', IODLST)
  256.               ELSE
  257.                 CALL ZCHOUT('  Unused variable: ', IODLST)
  258.               ENDIF
  259.               CALL ZPTMES(KEY, IODLST)
  260.             ELSE IF (ZIAND(SYMBOL(6,I),MASK).EQ.0) THEN
  261.               CALL ZCHOUT('  Variable n'//'ot explicitly set: ', IODLST)
  262.               COUNT = COUNT + 1
  263.               CALL ZPTMES(KEY, IODLST)
  264.             ENDIF
  265. C
  266. C  CHECK STATEMENT FUNCTIONS
  267. C
  268.           ELSE IF(SYMBOL(1,I) .EQ. 8) THEN
  269.             IF(ZIAND(SYMBOL(6,I), 125936) .EQ. 0) THEN
  270.               COUNT = COUNT + 1
  271.               CALL ZCHOUT('  Unused Statement Function: ', IODLST)
  272.               CALL ZPTMES(KEY, IODLST)
  273.             ELSE IF(ZIAND(SYMBOL(6,I), 8) .EQ. 0)THEN
  274.               IF(IMPLI) THEN
  275.                 COUNT = COUNT + 1
  276.                 CALL ZCHOUT
  277.      +              ('  Implicitly typed Statement Function: ', IODLST)
  278.                 CALL WRNAME(I)
  279.               ENDIF
  280.             ENDIF
  281. C
  282. C  CHECK PARAMETERS
  283. C
  284.           ELSE IF(SYMBOL(1,I) .EQ. 6) THEN
  285.             IF(ZIAND(SYMBOL(6,I), 125936) .EQ. 0) THEN
  286.               CALL ZCHOUT('  Unused Parameter: ', IODLST)
  287.               COUNT = COUNT + 1
  288.               CALL ZPTMES(KEY, IODLST)
  289.             ELSE IF(ZIAND(SYMBOL(6,I), 8) .EQ. 0)THEN
  290.               IF(IMPLI) THEN
  291.                 CALL ZCHOUT('  Implicitly typed Parameter: ', IODLST)
  292.                 COUNT = COUNT + 1
  293.                 CALL WRNAME(I)
  294.               ENDIF
  295.             ENDIF
  296. C
  297. C  CHECK EXTERNAL PROCEDURES
  298. C
  299.           ELSE IF(SYMBOL(1,I) .EQ. 7) THEN
  300.             IF(ZIAND(SYMBOL(6,I), 125936) .EQ. 0) THEN
  301.               CALL ZCHOUT('  Unused Procedure: ', IODLST)
  302.               COUNT = COUNT + 1
  303.               CALL ZPTMES(KEY, IODLST)
  304.             ELSE
  305.               IF(ZIAND(SYMBOL(6,I), 8) .EQ. 0)THEN
  306.                 IF(ZIAND(SYMBOL(6,I), 4096) .EQ. 0)THEN
  307.                   IF(ZIAND(SYMBOL(6,I), 8192) .NE. 0)THEN
  308.                     IF(IMPLI) THEN
  309.                       CALL ZCHOUT
  310.      +                     ('  Implicitly typed Procedure: ', IODLST)
  311.                       COUNT = COUNT + 1
  312.                       CALL WRNAME(I)
  313.                     ENDIF
  314.                   ENDIF
  315.                 ENDIF
  316.               ELSE
  317.                 IF(ZIAND(SYMBOL(6,I), 4096) .NE. 0)THEN
  318.                   CALL ZCHOUT('  Typed Standard Intrinsic: .', IODLST)
  319.                   COUNT = COUNT + 1
  320.                   CALL ZPTMES(KEY, IODLST)
  321.                 ENDIF
  322.               ENDIF
  323.               IF(ZIAND(SYMBOL(6,I), 4096) .NE. 0) THEN
  324.                 IF(ZIAND(SYMBOL(6,I), 2) .EQ. 0)THEN
  325.                   CALL ZCHOUT
  326.      +         ('  Intrinsic procedure n'//'ot in INTRINSIC: ', IODLST)
  327.                   COUNT = COUNT + 1
  328.                   CALL ZPTMES(KEY, IODLST)
  329.                 ENDIF
  330.               ELSE IF(ZIAND(SYMBOL(6,I), 1).EQ.0)THEN
  331.                 CALL ZCHOUT
  332.      +         ('  External procedure n'//'ot in EXTERNAL: ', IODLST)
  333.                 COUNT = COUNT + 1
  334.                 CALL ZPTMES(KEY, IODLST)
  335.               ENDIF
  336.             ENDIF
  337. C
  338. C  CHECK THE PROGRAM UNIT ITSELF.....
  339. C
  340.           ELSE IF(SYMBOL(1,I) .EQ. 4) THEN
  341.             IF(SYMBOL(4,I) .GT. 0) THEN
  342.               IF(ZIAND(SYMBOL(6,I), 125936) .EQ. 0) THEN
  343.                 CALL ZCHOUT('  Function value n'//'ot set: ', IODLST)
  344.                 COUNT = COUNT + 1
  345.                 CALL ZPTMES(KEY, IODLST)
  346.               ENDIF
  347.             ENDIF
  348.           ENDIF
  349. C
  350. C  END OF CHECKS, NEXT SYMBOL!
  351. C
  352.    20   CONTINUE
  353.         IF(COUNT .EQ. 0) CALL ZMESS('  No Warnings Detected..', IODLST)
  354.  
  355.         END
  356. C ----------------------------------------------------------------------
  357. C
  358. C       W R N A M E   -   Write symbol name and data type if any
  359. C
  360.  
  361.       SUBROUTINE WRNAME(N)
  362.       INTEGER N
  363.       INTEGER TEXT(134)
  364.       LOGICAL TEST1, TEST2
  365.       CHARACTER*17 TYPTXT(-3:15)
  366.  
  367.       COMMON/VSIO/IODSYM,IODLST
  368.       INTEGER IODSYM,IODLST
  369.  
  370.       COMMON/VSSYMI/SYMIDX,NSYMS
  371.       INTEGER SYMIDX(1000),NSYMS
  372.  
  373.       COMMON/VSSYMD/SYMBOL
  374.       INTEGER SYMBOL(8,1000)
  375.  
  376.       SAVE
  377.  
  378.         DATA TYPTXT/
  379.      +'Main Program.    ',
  380.      +'Block-data.      ',
  381.      +'Routine.         ',
  382.      +'Unknown.         ',
  383.      +'INTEGER.         ',
  384.      +'REAL.            ',
  385.      +'LOGICAL.         ',
  386.      +'COMPLEX.         ',
  387.      +'DOUBLE PRECISION.',
  388.      +'CHARACTER.       ',
  389.      +'DOUBLE COMPLEX.  ',
  390.      +'Generic.         ',
  391.      +'Hollerith.       ',
  392.      +'Label.           ',
  393.      +'Substring spec.  ',
  394.      +'LOGICAL*1.       ',
  395.      +'LOGICAL*2.       ',
  396.      +'INTEGER*2.       ',
  397.      +'REAL*16.         '/
  398.  
  399.       CALL ZYGTST(SYMBOL(2,N),TEXT)
  400.       CALL PUTLIN(TEXT,IODLST)
  401.       CALL ZLEGAL(TEXT, TEST1, TEST2)
  402.  
  403.       IF (SYMBOL(1,N).EQ.1) RETURN
  404.       IF (SYMBOL(1,N).EQ.2) GO TO 10
  405.  
  406.       CALL ZCHOUT(' (',IODLST)
  407.       CALL ZCHOUT(TYPTXT(SYMBOL(4,N)),IODLST)
  408.       IF (SYMBOL(5,N).NE.0) THEN
  409.           CALL PUTCH(42,IODLST)
  410.           IF (SYMBOL(5,N).GT.0) THEN
  411.               CALL ZPTINT(SYMBOL(5,N),1,IODLST)
  412.           ELSE
  413.               CALL ZCHOUT('(?)',IODLST)
  414.           END IF
  415.       END IF
  416.       IF (SYMBOL(1,N).EQ.4 .AND.
  417.      +      SYMBOL(4,N).GT.0) THEN
  418.          CALL ZCHOUT(' FUNCTION)',IODLST)
  419.       ELSE
  420.          CALL ZCHOUT(')',IODLST)
  421.       ENDIF
  422.  
  423.    10 CONTINUE
  424.       IF(TEST1) THEN
  425.         IF(TEST2) CALL PUTCH(10, IODLST)
  426.         IF(.NOT.TEST2)CALL ZMESS(' - Name n'//'ot locally legal',IODLST)
  427.       ELSE
  428.         IF(.NOT.TEST2)CALL ZMESS(' - Name n'//'ot legal', IODLST)
  429.         IF(TEST2)CALL ZMESS(' - Name non-standard',IODLST)
  430.       ENDIF
  431.  
  432.       END
  433.